home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / language / ici / ici.cpi / call.c < prev    next >
C/C++ Source or Header  |  1994-10-27  |  5KB  |  218 lines
  1. #include "buf.h"
  2. #include "exec.h"
  3. #include "func.h"
  4. #include "int.h"
  5. #include "float.h"
  6. #include "str.h"
  7. #include "null.h"
  8. #include "op.h"
  9. #include "catch.h"
  10. #include <stdarg.h>
  11.  
  12. /*
  13.  * The common code used by ici_func() and ici_call() below.
  14.  */
  15. static char *
  16. call(object_t *func_obj, char *types, va_list va)
  17. {
  18.     object_t        *call_obj;
  19.     catch_t        *frame;
  20.     int            nargs;
  21.     int            arg;
  22.     object_t        *ret_obj;
  23.     char        ret_type;
  24.     char        *ret_ptr;
  25.     int            os_depth;
  26.  
  27.     if (types[0] != '\0' && types[1] == '=')
  28.     {
  29.     ret_type = types[0];
  30.     ret_ptr = va_arg(va, char *);
  31.     types += 2;
  32.     }
  33.     else
  34.     {
  35.     ret_type = '\0';
  36.     ret_ptr = NULL;
  37.     }
  38.  
  39.     os_depth = o_top - os->a_base;
  40.     call_obj = NULL;
  41.     /*
  42.      * We include an extra 80 in our pushcheck, see start of evaluate().
  43.      */
  44.     nargs = strlen(types);
  45.     if (pushcheck(os, nargs + 80))
  46.     return error;
  47.     for (arg = 0; arg < nargs; ++arg)
  48.     *o_top++ = objof(&o_null);
  49.     for (arg = -1; arg >= -nargs; --arg)
  50.     {
  51.     switch (*types++)
  52.     {
  53.     case 'o':
  54.         o_top[arg] = va_arg(va, object_t *);
  55.         break;
  56.  
  57.     case 'i':
  58.         if ((o_top[arg] = objof(new_int(va_arg(va, long)))) == NULL)
  59.         goto fail;
  60.         loose(o_top[arg]);
  61.         break;
  62.  
  63.     case 'q':
  64.         o_top[arg] = objof(&o_quote);
  65.         --nargs;
  66.         break;
  67.  
  68.     case 's':
  69.         if ((o_top[arg] = objof(new_cname(va_arg(va, char *)))) == NULL)
  70.         goto fail;
  71.         loose(o_top[arg]);
  72.         break;
  73.  
  74.     case 'f':
  75.         if ((o_top[arg] = objof(new_float(va_arg(va, double)))) == NULL)
  76.         goto fail;
  77.         loose(o_top[arg]);
  78.         break;
  79.  
  80.     default:
  81.         error = "error in function call";
  82.         goto fail;
  83.     }
  84.     }
  85.     *o_top++ = func_obj;
  86.     if ((call_obj = objof(new_op(NULL, OP_CALL, nargs))) == NULL)
  87.     goto fail;
  88.     if ((frame = new_catch(NULL, os_depth, v_top - vs->a_base)) == NULL)
  89.     goto fail;
  90.     if ((ret_obj = ici_evaluate(objof(call_obj), frame)) == NULL)
  91.     goto fail;
  92.     switch (ret_type)
  93.     {
  94.     case '\0':
  95.     loose(ret_obj);
  96.     break;
  97.  
  98.     case 'o':
  99.     *(object_t **)ret_ptr = ret_obj;
  100.     break;
  101.  
  102.     case 'i':
  103.     if (!isint(ret_obj))
  104.         goto typeclash;
  105.     *(long *)ret_ptr = intof(ret_obj)->i_value;
  106.     loose(ret_obj);
  107.     break;
  108.  
  109.     case 'f':
  110.     if (!isfloat(ret_obj))
  111.         goto typeclash;
  112.     *(double *)ret_ptr = floatof(ret_obj)->f_value;
  113.     loose(ret_obj);
  114.     break;
  115.  
  116.     case 's':
  117.     if (!isstring(ret_obj))
  118.         goto typeclash;
  119.     *(char **)ret_ptr = stringof(ret_obj)->s_chars;
  120.     loose(ret_obj);
  121.     break;
  122.  
  123.     default:
  124.     typeclash:
  125.     loose(ret_obj);
  126.     error = "incorrect return type";
  127.     goto fail;
  128.     }
  129.     loose(call_obj);
  130.     return NULL;
  131.  
  132. fail:
  133.     if (call_obj != NULL)
  134.     loose(call_obj);
  135.     o_top = os->a_base + os_depth;
  136.     return error;
  137. }
  138.  
  139. /*
  140.  * ici_func(func, types, args...)
  141.  *
  142.  * Call an ICI function from C with simple argument types and return value.
  143.  *
  144.  * Types can be of the forms ".=..." or "...".  In the first case the 1st
  145.  * extra arg is used as a pointer to store the return value through.
  146.  *
  147.  * Type key letters are:
  148.  *     i    a long
  149.  *    f     a double
  150.  *    s    a '\0' terminated string
  151.  *    o    an ici object
  152.  *
  153.  * When a string is returned it is a pointer to the character data of an
  154.  * internal ICI string object. It will only remain valid until the next
  155.  * call to any ICI function.  When an object is returned it is not loose
  156.  * (i.e. it is held against garbage collection).
  157.  */
  158. char *
  159. ici_func(object_t *func_obj, char *types, ...)
  160. {
  161.     va_list    va;
  162.     char    *result;
  163.  
  164.     va_start(va, types);
  165.     result = call(func_obj, types, va);
  166.     va_end(va);
  167.     return result;
  168. }
  169.  
  170. /*
  171.  * ici_call(name, types, args...)
  172.  *
  173.  * Call an ici function by name from C with simple argument types and
  174.  * return value.  The named is looked up in the current scope.
  175.  *
  176.  * Types can be of the forms ".=..." or "...".  In the first case the 1st
  177.  * extra arg is used as a pointer to store the return value through.
  178.  *
  179.  * Type key letters are:
  180.  *     i    a long
  181.  *    f     a double
  182.  *    s    a '\0' terminated string
  183.  *    o    an ici object
  184.  *
  185.  * When a string is returned it is a pointer to the character data of an
  186.  * internal ICI string object. It will only remain valid until the next
  187.  * call to any ICI function.  When an object is returned it is not loose
  188.  * (i.e. it is held against garbage collection).
  189.  */
  190. char *
  191. ici_call(char *func_name, char *types, ...)
  192. {
  193.     object_t        *name_obj;
  194.     object_t        *func_obj;
  195.     va_list        va;
  196.     char        *result;
  197.     
  198.     name_obj = NULL;
  199.     func_obj = NULL;
  200.  
  201.     va_start(va, types);
  202.     if ((name_obj = objof(new_cname(func_name))) == NULL)
  203.     return error;
  204.     if ((func_obj = fetch(v_top[-1], name_obj)) == objof(&o_null))
  205.     {
  206.     sprintf(buf, "\"%s\" undefined", func_name);
  207.     error = buf;
  208.     loose(name_obj);
  209.     return error;
  210.     }
  211.     loose(name_obj);
  212.     name_obj = NULL;
  213.     result = call(func_obj, types, va);
  214.     loose(func_obj);
  215.     va_end(va);
  216.     return result;
  217. }
  218.